;;;
;;; twitter
;;;

(defpackage #:twitter.setagaya.mc
  (:use #:cl #:drakma #:net.html.parser #:pg)
  (:nicknames #:twitter #:twitter.setagaya)
  (:export #:update-twitter-status
	   #:get-recent-twitter-entry))

(in-package #:twitter.setagaya.mc)

;; 投稿
(defun update-twitter-status (mesg)
  "twitterに投稿する。パスワードファイルは、~/.twitter.lisp
~/.twitter.lisp 書式:
;; twitter
\((:username . \"おなまえ\") 
 (:password . \"パスワード\"))"
  (let ((mesg-list (split-by-length mesg 50))
	(cj (make-instance 'cookie-jar)))
    (multiple-value-bind (username password) (read-password-file)
      ;; login
      (http-request "http://twitter.com/sessions" 
			   :external-format-in :utf-8 
			   :external-format-out :utf-8
			   :method :post
			   :cookie-jar cj
			   :parameters `(("username_or_email" . ,username) 
					 ("password" . ,password)))
      ;; update
      (do ((m mesg-list (cdr m)))
	  ((endp m) (length mesg))
	(http-request "http://twitter.com/status/update" 
			     :external-format-in :utf-8
			     :external-format-out :utf-8
			     :method :post
			     :cookie-jar cj
			     :parameters `(("status" . ,(car m))))
	(unless (endp (cdr m)) (sleep 5))))))

;; 読み出し
(defun get-recent-twitter-entry ()
  "最近のログを内容の文字列と時刻のalistにして返す。最近が先頭になる。"
  (let (res)
    (dolist (l (get-recent-contents (get-twitter-log)) (nreverse res))
      (push `(,(get-entry l) 
	       ,(tlist->tstring
		 (tstring->tlist (get-entry-published-time l)) -9))
	    res))))

;; ----------------------------------------------------------------
(defun tstring->tlist (str)
  "twitterの時刻形式をuniversal-time形式に変換"
  (let ((scn (cl-ppcre:create-scanner
	      "([0-9]...)-([01][0-9])-([0123][0-9])T([012][0-9]):([0-5][0-9]):([0-5][0-9])\\+([012][0-9]):([0-5][0-9])")))
    (destructuring-bind (y mo d h m s off set)
	(map 'list #'parse-integer
	     (nth-value 1 (cl-ppcre:scan-to-strings scn str)))
      (declare (ignore set))
      (encode-universal-time s m h d mo y off))))

(defun tlist->tstring (time timezone)
  "universal-time形式からtwitterの時刻形式に変換。タイムゾーンを指定する必要がある"
  (multiple-value-bind (s m h d mo y ig nore tz) (decode-universal-time time timezone)
    (declare (ignore ig nore))
    (format nil "~D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[+~;-~]~2,'0D:00" y mo d h m s (minusp tz) (abs tz))))

(defun split-by-length (str len)
  "指定した長さ`len'で文字列`str'を区切り、結果を文字列のリストにして返す。"
  (let ((slen (length str)))
    (if (> slen len)
	(do ((pos len (+ pos len))
	     res)
	    ((> pos slen) 
	     (nreverse (push (subseq str (- pos len) slen) res)))
	  (push (subseq str (- pos len) pos) res))
	`(,str))))

(defun read-password-file (&optional (path (merge-pathnames ".twitter.lisp" (user-homedir-pathname))))
  (let ((file (probe-file path)))
    (if file
	(with-open-file (str file :direction :input)
	  (let ((user-alist (read str nil nil)))
	    (values (cdr (assoc :username user-alist))
		    (cdr (assoc :password user-alist)))))
	(error "初期化ファイル:~~/.twitterが存在していません。:~A" path))))

(defun get-twitter-log ()
  "twitterの自分のログを見る。パスワードファイルは、~/.twitter.lisp
~/.twitter.lisp 書式:
;; twitter
\((:username . \"おなまえ\") 
 (:password . \"パスワード\"))"
  (let ((cj (make-instance 'cookie-jar)))
    (multiple-value-bind (username password) (read-password-file)
      ;; login
      (http-request "http://twitter.com/sessions" 
			   :external-format-in :utf-8 
			   :external-format-out :utf-8
			   :method :post
			   :cookie-jar cj
			   :parameters `(("username_or_email" . ,username) 
					 ("password" . ,password)))
      ;; update
      (parse-html
       (http-request "http://twitter.com/home" 
			    :external-format-in :utf-8
			    :external-format-out :utf-8
			    :method :post
			    :cookie-jar cj)))))


(defun contentp (form)
  "コンテンツかどうかを判定する"
  (if (consp form)
      (let ((tag (car form)))
	(when (and (consp tag)
		   (eq (car tag) :td)
		   (eq (cadr tag) :class)
		   (string-equal (caddr tag) "content"))
	  (cadr form)))
      nil))

(defun get-recent-contents (tree)
  "コンテンツを集めてリストにして返す"
  (let (res)
    (labels ((frob (tree)
	       (if tree
		   (if (consp tree)
		       (if (contentp tree)
			   (push tree res)
			   `(,(frob (car tree))
			      ,(frob (cdr tree)))))
		   nil)))
      (frob tree))
    (nreverse res)))

(defun get-string-mesg (form)
  "URLだけのエントリの場合、さらにパーズが必要になるので、それの対策"
  (if (stringp form)
      form
      (if (eq (caar form) :a) 		;((:A :HREF "http://tinyurl.com/2zn〜))が来る
	  (caddar form)			;url部分を返す
	  "どっかがおかしいと思う:twitter.setagaya::get-string-mesgを調べてみよう")))

(defun entryp (form)
  "エントリだったらそのエントリの文字列を返す"
  (if (consp form)
      (let ((tag (car form)))
	(when (and (consp tag)
		   (eq (car tag) :span)
		   (eq (cadr tag) :class)
		   (string-equal (caddr tag) "entry-title entry-content"))
	  #|(cadr form)|#
	  (get-string-mesg (cadr form))))
      nil))

(defun get-entry (tree)
  "エントリを探してエントリの整形済みの文字列を返す"
  (labels ((frob (tree)
	     (if tree
		 (if (consp tree)
		     (aif (entryp tree)
			  (return-from get-entry
			    (string-trim '(#\Newline #\Return #\Space #\Tab) it))
			  `(,(frob (car tree))
			     ,(frob (cdr tree)))))
		 nil)))
    (frob tree)))

(defun published-time-p (form)
  "内容が時刻だったら時刻の文字列を返す"
  (if (consp form)
      (when (and (consp form)
		 (eq (car form) :ABBR)
		 (eq (cadr form) :class)
		 (string-equal (caddr form) "published"))
	  (fifth form))
      nil))

(defun get-entry-published-time (tree)
  "エントリが登録された時刻を探す"
  (labels ((frob (tree)
	       (if tree
		   (if (consp tree)
		       (aif (published-time-p tree)
			    (return-from get-entry-published-time it)
			    `(,(frob (car tree))
			       ,(frob (cdr tree)))))
		   nil)))
    (frob tree)))
